home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / business / litlbk24.zip / LITLBOOK.PAS < prev   
Pascal/Delphi Source File  |  1987-05-29  |  50KB  |  1,530 lines
  1.  
  2. {$C-}
  3.  
  4. PROGRAM LitlBook;   { Copyright (C)1986,87 by Jamestown Software }
  5.                     { Written by Kenn Flee, Jamestown Software   }
  6.                     { 2508 Valley Forge, Madison WI 53719        }
  7.                     { NonCommercial Use Only           5/18/86   }
  8.  
  9.                     { Requires Turbo Database Toolbox to compile }
  10.  
  11. CONST
  12.   MaxDataRecSize = 300;
  13.   MaxKeyLen      =  15;
  14.   PageSize       =  24;
  15.   Order          =  12;
  16.   PageStackSize  =   8;
  17.   MaxHeight      =   5;
  18.  
  19.   ClassFileName = 'LITLCLAS.DAT';
  20.   DataFileName  = 'LITLBOK2.DAT';
  21.   IndexFileName = 'LITLBOK2.IXN';
  22.  
  23. {.L-}
  24. {$I ACCESS.BOX}
  25. {$I GETKEY.BOX}
  26. {$I ADDKEY.BOX}
  27. {$I DELKEY.BOX}
  28. {$I SORT.BOX}
  29. {.L+}
  30.  
  31. TYPE
  32.   Str8    = String[8];
  33.   Str35   = String[35];
  34.   Str80   = String[80];
  35.   Str255  = String[255];
  36.   AnyStr  = String[255];
  37.   CharSet = Set of Char;
  38.   RegPack = record case Integer of
  39.               1: (AX,BX,CX,DX,BP,SI,DS,ES,Flags : integer);
  40.               2: (AL,AH,BL,BH,CL,CH,DL,DH       : Byte   );
  41.             end;
  42.   DataRecord = Record
  43.                  Status    : Integer;
  44.                  FName     : String[15];
  45.                  LName     : String[30];
  46.                  Address   : String[25];
  47.                  CityState : String[25];
  48.                  Zip       : String[10];
  49.                  Phone1    : String[12];
  50.                  Phone2    : String[12];
  51.                  Class     : String[2];
  52.                  Comment   : String[79];
  53.                End;
  54.  
  55.  
  56. VAR
  57.   Regs         : RegPack;
  58.   Ch           : Char;
  59.   DRec,DRec2   : DataRecord;
  60.   DFile        : DataFile;
  61.   IFile        : IndexFile;
  62.   ClassList    : Array[1..30] of Str35;
  63.   CFile        : File of Str35;
  64.   OutFile      : Text;
  65.   Key          : String[15];
  66.   RecNum       : Integer;
  67.   TDate        : Str8;
  68.   EDrive       : Str80;
  69.   MenuChoice,
  70.   ReportChoice : Char;
  71.   HiAt,LoAt    : Byte;
  72.   Abort        : Boolean;
  73.   ClassSort    : Boolean;
  74.   ZipSort      : Boolean;
  75.   Labels       : Boolean;
  76.   HardCopy     : Boolean;
  77.   LastNameFirst: Boolean;
  78.   ParamRead    : Boolean;
  79.   AsciiFile    : Boolean;
  80.   AsciiName    : Str80;
  81.   RunCount     : Integer;
  82.  
  83. {-----------------------------------------------------------------------
  84.   Turbo Database Toolbox Summary:
  85.  
  86.   MakeFile(DataFileVar,FileName,RecordLength); *
  87.    - Creates a new data file and prepares it for processing.
  88.   OpenFile(DataFileVar,FileName,RecordLength); *
  89.    - Opens an existing data file and prepares it for processing.
  90.   CloseFile(DataFileVar);
  91.    - Closes a data file.
  92.   AddRec(DataFileVar,RecordNumber,Buffer);
  93.    - Adds a new record to data file; returns RecordNumber.
  94.   DeleteRec(DataFileVar,RecordNumber);
  95.    - Deletes specified record.
  96.   GetRec(DataFileVar,RecordNumber,Buffer);
  97.    - Reads specified record into buffer.
  98.   PutRec(DataFileVar,RecordNumber,Buffer);
  99.    - Writes record to specified record number.
  100.   FileLen(DataFileVar);
  101.    - Returns number of records ASSIGNED to data file.
  102.   UsedRecs(DataFileVar);
  103.    - Returns number of records in use.
  104.  
  105.   InitIndex;
  106.    - Call before using any index file routines, once only.
  107.   MakeIndex(IndexFileVar,FileName,KeyLength,Status); *
  108.    - Creates new index file; Status 0=No dup keys allowed, 1=dups allowed.
  109.   OpenIndex(IndexFileVar,FileName,KeyLength,Status); *
  110.    - Opens existing index file.
  111.   CloseIndex(IndexFileVar);
  112.    - Closes index file.
  113.   AddKey(IndexFileVar,RecordNumber,Key); *
  114.    - Adds a key using Record Number returned by AddRec.
  115.   DeleteKey(IndexFileVar,RecordNumber,Key); *
  116.    - Deletes key; Record number used if dup keys allowed.
  117.   FindKey(IndexFileVar,RecordNumber,Key); *
  118.    - Returns record number of a MATCHING key.
  119.   SearchKey(IndexFileVar,RecordNumber,Key); *
  120.    - Returns record number of first key EQUAL TO or GREATER THAN specified key.
  121.   NextKey(IndexFileVar,RecordNumber,Key); *
  122.    - Returns next record number after specified key, plus new key.
  123.    - Must use FindKey, SearchKey or ClearKey before first use or after
  124.      AddKey or DeleteKey;
  125.   PrevKey(IndexFileVar,RecordNumber,Key); *
  126.    - Returns preceeding record number to specified key, plus new key.
  127.    - Must use FindKey, SearchKey or ClearKey before first use or after
  128.      AddKey or DeleteKey;
  129.   ClearKey
  130.    - Sets index file pointer to beginning/end of index file.
  131.  
  132.   * OK - A boolean var. generally set to TRUE on success and FALSE on error.
  133.  
  134. -----------------------------------------------------------------------------}
  135.  
  136. (* SCREEN CODE -------------------------------------------------------*)
  137.  
  138. CONST  VideoEnable = $08;               { Video Signal Enable Bit }
  139.        CurrentSaved : Boolean = False;
  140.        On  = True;
  141.        Off = False;
  142.  
  143. TYPE   Imagetype  = Array[1..4000] of char;  { Screen Image }
  144.  
  145. VAR    Screen      : Record
  146.                        Image: Imagetype;
  147.                        X1,Y1:   Integer;
  148.                      End;
  149.        Crtmode     : Byte      ABSOLUTE $0040:$0049;
  150.        Monobuffer  : Imagetype ABSOLUTE $B000:$0000;
  151.        Colorbuffer : Imagetype ABSOLUTE $B800:$0000;
  152.        CrtAdapter  : Integer   ABSOLUTE $0040:$0063;
  153.        VideoMode   : Byte      ABSOLUTE $0040:$0065;
  154.  
  155.  
  156. PROCEDURE Video(Switch:Boolean); { Video On/Off to avoid Read/Write snow }
  157.   Begin
  158.     If (Switch=Off) then Port[CrtAdapter+4] := (VideoMode-VideoEnable)
  159.       Else Port[CrtAdapter+4] := (VideoMode or VideoEnable);
  160.   End;
  161.  
  162. PROCEDURE SaveScreen;
  163.   Begin
  164.     If NOT CurrentSaved then begin
  165.       Video(Off);
  166.       With Screen Do Begin
  167.         X1:=WhereX;
  168.         Y1:=WhereY;
  169.         If CrtMode = 7 then Image := Monobuffer Else Image := Colorbuffer ;
  170.       End;
  171.       Video(On);
  172.       CurrentSaved:=True;
  173.     End;
  174.   End; { procedure SaveScreen }
  175.  
  176. PROCEDURE RestoreScreen;
  177.   Begin
  178.     If CurrentSaved then begin
  179.       Video(Off);
  180.       With Screen Do Begin
  181.         If CrtMode = 7 then Monobuffer := Image Else Colorbuffer := Image;
  182.         GotoXY(X1,Y1);
  183.       End;
  184.       Video(On);
  185.       CurrentSaved:=False;
  186.     End;
  187.   End; { procedure RestoreScreen; }
  188.  
  189. PROCEDURE FastWrite(col,row,attrib:byte;str:str80);  { by Marshall Brain }
  190.   Begin                                       { col = 0..79, row = 0..24 }
  191.     inline
  192.       ($1E/$1E/$8A/$86/row/$B3/$50/$F6/$E3/$2B/$DB/$8A/$9E/col/
  193.        $03/$C3/$03/$C0/$8B/$F8/$be/$00/$00/$8A/$BE/attrib/
  194.        $8a/$8e/str/$22/$c9/$74/$3e/$2b/$c0/$8E/$D8/$A0/$49/$04/
  195.        $1F/$2C/$07/$74/$22/$BA/$00/$B8/$8E/$DA/$BA/$DA/$03/$46/
  196.        $8a/$9A/str/$EC/$A8/$01/$75/$FB/$FA/$EC/$A8/$01/$74/$FB/
  197.        $89/$1D/$47/$47/$E2/$Ea/$2A/$C0/$74/$10/$BA/$00/$B0/
  198.        $8E/$DA/$46/$8a/$9A/str/$89/$1D/$47/$47/$E2/$F5/$1F);
  199.   End; { procedure FastWrite }
  200.  
  201. {------------------------------------------------------------------------}
  202.  
  203. FUNCTION DOSDate:Str8;
  204.   VAR
  205.     mstr,dstr:     string[2];
  206.     ystr:          string[4];
  207.   begin
  208.     Regs.AX := $2A00;
  209.     MsDos(Regs);
  210.     with Regs do begin
  211.       str(cx,ystr);                        {convert to string}
  212.       str(dx mod 256,dstr);                     { " }
  213.       str(dx shr 8,mstr);                       { " }
  214.     end;
  215.     Ystr:=Copy(Ystr,3,2);
  216.     If Length(Dstr) = 1 then Dstr:='0'+Dstr;
  217.     DOSdate := mstr + '/' + dstr + '/' + ystr  ;
  218.   end;
  219.  
  220. FUNCTION ConstStr(C:Char; N:Integer) : Str80;
  221.   VAR S : String[80];
  222.   Begin
  223.     If N<0 then N:=0;
  224.     S[0] := Chr(N);
  225.     FillChar(S[1],N,C);
  226.     ConstStr := S;
  227.   End; { function ConstStr }
  228.  
  229. FUNCTION MonitorType : Integer;
  230.   Begin
  231.     MonitorType := Mem[$0040:$0049];
  232.   End; { function MonitorType }
  233.  
  234. PROCEDURE HideCursor;
  235.   Begin
  236.     Inline($B9/$0F00/$B4/$01/$CD/$10);
  237.   End; { procedure HideCursor }
  238.  
  239. PROCEDURE RestoreCursor;
  240.   Begin
  241.     If MonitorType = 7 then                  { Mono }
  242.       Inline($B9/$0C0D/$B4/$01/$CD/$10)
  243.     Else Inline($B9/$0607/$B4/$01/$CD/$10);  { CGA }
  244.   End; { procedure RestoreCursor }
  245.  
  246. PROCEDURE Beep;
  247.   Begin
  248.     Sound(1440);Delay(60);
  249.     NoSound;
  250.   End; { procedure Beep }
  251.  
  252. PROCEDURE Boop;
  253.   Begin
  254.     Sound(330);Delay(120);
  255.     NoSound;
  256.   End; { procedure Boop }
  257.  
  258. FUNCTION Yes: Boolean;
  259.   VAR Ch:Char;
  260.   Begin
  261.     Repeat
  262.       Read(Kbd,Ch);
  263.       Ch:=UpCase(Ch);
  264.       If Not (Ch in ['Y','N']) then Boop;
  265.     Until Ch in ['Y','N'];
  266.     Yes := (Ch='Y');
  267.   End; { function Yes }
  268.  
  269. FUNCTION PrReady: Boolean;
  270.   VAR I : Integer;
  271.   Begin
  272.     Regs.ax:=$0200;
  273.     Regs.dx:=$0000;
  274.     Intr($17,Regs);
  275.     I := ((regs.ax and $FF00) shr 8);
  276.     If (I=144) then PrReady := True
  277.       Else PrReady := False;
  278.   End; { function PrReady }
  279.  
  280. PROCEDURE PrinterWarning;
  281.   Begin
  282.     SaveScreen;
  283.     FastWrite(15,16,HiAt,'┌──────────────────────────────────────────────────┐');
  284.     FastWrite(15,17,HiAt,'│      Printer does not appear to be ready...      │');
  285.     FastWrite(15,18,HiAt,'│      Press any key when problem is fixed,        │');
  286.     FastWrite(15,19,HiAt,'│            or <ESC> to return to Main Menu.      │');
  287.     FastWrite(15,20,HiAt,'└──────────────────────────────────────────────────┘');
  288.     Repeat
  289.       Beep;
  290.       Read(Kbd,Ch);
  291.       If (Ch=#27) and (NOT Keypressed) then begin
  292.         Abort:=True;
  293.         RestoreScreen;
  294.         Exit;
  295.       End;
  296.     Until PrReady;
  297.     RestoreScreen;
  298.   End; { procedure PrinterWarning }
  299.  
  300. PROCEDURE PrinterSet;
  301.   Begin
  302.     SaveScreen;
  303.     FastWrite(15,16,HiAt,'┌──────────────────────────────────────────────────┐');
  304.     FastWrite(15,17,HiAt,'│     Position printer at top of new page...       │');
  305.     FastWrite(15,18,HiAt,'│     Press any key when ready or <ESC> to quit.   │');
  306.     FastWrite(15,19,HiAt,'└──────────────────────────────────────────────────┘');
  307.     Beep;
  308.     Read(Kbd,Ch);
  309.     If (Ch=#27) and (NOT Keypressed) then Abort:=True;
  310.     RestoreScreen;
  311.   End; { procedure PrinterSet }
  312.  
  313. PROCEDURE SetAt;
  314.   Begin
  315.     LoAt:=$07;
  316.     If MonitorType = 7 then HiAt:=$0F else HiAt:=$0E;
  317.   End; { procedure SetAt }
  318.  
  319. FUNCTION Freespace:real;
  320.   VAR  fr : real;
  321.   Begin
  322.     With Regs do begin
  323.       dx := 0;
  324.       ah := $36;
  325.       MsDos(Regs);
  326.       fr := bx;
  327.       if ax <> $FFFF then Freespace := fr * ax * cx else Freespace := 0
  328.     End;
  329.   End;  { function Freespace }
  330.  
  331. Function CenterStr(S:Str255; Size:Byte) : Str255;
  332.   VAR I:Integer;
  333.   Begin
  334.     I:=Size-Length(s);
  335.     I:=Trunc(I/2);
  336.     CenterStr:=ConstStr(' ',I)+S+ConstStr(' ',size-Length(S)-I);
  337.   End;
  338.  
  339. PROCEDURE DisplayID;
  340.   Begin
  341.     ClrScr;
  342.     HideCursor;
  343.     FastWrite(10,0,HiAt,'┌───────────────────────────────────────────────────────────┐');
  344.     FastWrite(10,1,HiAt,'│                                                           │');
  345.     FastWrite(10,2,HiAt,'│                                                           │');
  346.     FastWrite(10,3,HiAt,'│                                                           │');
  347.     FastWrite(10,4,HiAt,'│                                                           │');
  348.     FastWrite(10,5,HiAt,'└───────────────────────────────────────────────────────────┘');
  349.     FastWrite(12,1,HiAt,CenterStr('LITLBOOK -- A User-Supported Address Book Program  V2.4',58));
  350.     FastWrite(12,2,HiAt,CenterStr('----------',58));
  351.     FastWrite(12,3,LoAt,CenterStr('Written by Kenn Flee of Jamestown Software',58));
  352.     FastWrite(12,4,LoAt,CenterStr('2508 Valley Forge Dr., Madison WI  53719  (C)1986,87',58));
  353.     RunCount:=RunCount-1;
  354.     If RunCount<1 then begin
  355.       FastWrite(12,6,LoAt,CenterStr('Your support of $5-$10 would be appreciated.',58));
  356.       RunCount:=8;
  357.     End;
  358.     RestoreCursor;
  359.   End;
  360.  
  361. FUNCTION Exist(FileName : Str80) : Boolean;
  362.   VAR
  363.     Fil : file;
  364.   Begin
  365.     Assign(Fil,FileName);
  366.     {$I-}
  367.     Reset(Fil);
  368.     {$I+}
  369.     Exist := (IOResult=0);
  370.     Close(Fil);
  371.   End;
  372.  
  373. TYPE FieldType = (Af,Nf,Rf,Df,Yf);    { Alpha, Numeric, Real, Date, Yes/No }
  374.  
  375. PROCEDURE InputStr (VAR S : AnyStr;
  376.                         L,X,Y : Integer;
  377.                         FType : FieldType;
  378.                         Term : CharSet;
  379.                     VAR TC : Char);
  380.   CONST
  381.     UnderScore = '_';
  382.   VAR
  383.     P : Integer;
  384.     Ch,Ch2 : Char;
  385.     LegalChar : CharSet;
  386.     FirstChar : Boolean;
  387.     EntryString : AnyStr;
  388.     X1,X2,X3 : Integer;
  389.     Error : Boolean;
  390.   Begin
  391.     Case FType of
  392.       Af : LegalChar := [' '..'~'];             { Alpha }
  393.       Nf : LegalChar := ['-','0'..'9'];         { Numeric }
  394.       Rf : LegalChar := ['-','.','0'..'9'];     { Real }
  395.       Df : LegalChar := ['/','0'..'9'];         { Date }
  396.       Yf : LegalChar := ['Y','y','N','n'];      { Yes/No }
  397.     End; { case }
  398.     GotoXY(X,Y); Write(S,ConstStr(UnderScore,L-Length(S)));
  399.     P := 0;
  400.     FirstChar := True;
  401.     EntryString := S;
  402.     Repeat
  403.       GotoXY(X+P,Y);
  404.       Read(Kbd,Ch);
  405.       If ((Ch in [#32..#126]) and FirstChar) then begin
  406.         P:=0;
  407.         S:='';
  408.         Write(S,ConstStr(UnderScore,L-Length(S)));
  409.         GotoXY(X+P,Y);
  410.       End;
  411.       FirstChar := False;
  412.       Case Ch of
  413.         #32..#126 : If (P<L) and (Ch in LegalChar) then
  414.                     Begin
  415.                       If FType = Yf then begin
  416.                         Case Ch of
  417.                           'Y','y' : S := 'Yes';
  418.                           'N','n' : S := 'No ';
  419.                         End;
  420.                         P:=0;
  421.                         GotoXY(X+P,Y);
  422.                         Write(S,ConstStr(UnderScore,L-Length(S)));
  423.                         Ch := #13;
  424.                       End Else begin
  425.                         If Length(S)=L then Delete(S,L,1);
  426.                         P := P+1;
  427.                         Insert(Ch,S,P);
  428.                         Write(Copy(S,P,L));
  429.                       End;
  430.                     End
  431.                     Else Beep;
  432.                ^H : If P>0 then
  433.                     Begin
  434.                       Delete(S,P,1);
  435.                       Write(^H,Copy(S,P,L),UnderScore);
  436.                       P := P-1;
  437.                     End
  438.                     Else Beep;
  439.               #27 : If KeyPressed then Begin
  440.                       Read(Kbd,Ch2);
  441.                       Case Ch2 of
  442.                       #27 : Ch := #27;
  443.  
  444.                       { Func. Codes: F1=59 F2=60 F3=61 ... F10=68 }
  445.  
  446.                       #59 : Ch := ^Q;
  447.                       #62 : Begin
  448.                               P:=0;
  449.                               S:='';
  450.                               GotoXY(X+P,Y);
  451.                               Write(S,ConstStr(UnderScore,L-Length(S)));
  452.                             End;
  453.                       #68 : Ch := ^Z;
  454.  
  455.                       { Keypad Codes:  71 72 73
  456.                                        75 76 77
  457.                                        79 80 81
  458.                                     -82- -83-    }
  459.  
  460.                       #75 : If P>0 then P := P-1
  461.                             Else Beep;
  462.                       #77 : If P<Length(S) then P := P+1
  463.                             Else Beep;
  464.                       #79 : P := Length(S);
  465.                       #71 : P := 0;
  466.                       #72 : Ch := ^E;
  467.                       #80 : Ch := ^X;
  468.                       #83 : If P<Length(S) then
  469.                             Begin
  470.                               Delete(S,P+1,1);
  471.                               Write(Copy(S,P+1,L),UnderScore);
  472.                             End;
  473.                       End; {case}
  474.                     End Else Begin
  475.                       S := EntryString;
  476.                       P:=0;
  477.                       GotoXY(X+P,Y);
  478.                       Write(S,ConstStr(UnderScore,L-Length(S)));
  479.                       Ch := #13;
  480.                     End; {begin}
  481.       End; {case}
  482.       If (Ch in Term) and (FType = Df) then begin
  483.         Error := False;
  484.         Val(Copy(S,1,2),X3,X2);
  485.         If X2<>0 then Error := True;
  486.         Val(Copy(S,4,2),X1,X2);
  487.         If X2=0 then
  488.           Case X1 of
  489.             4,6,9,11        : If NOT (X3 in [1..30]) then Error := True;
  490.             1,3,5,7,8,10,12 : If NOT (X3 in [1..31]) then Error := True;
  491.             2               : If NOT (X3 in [1..29]) then Error := True
  492.            Else Error := True;
  493.         End Else Error := True;
  494.         Val(Copy(S,7,2),X1,X2);
  495.         If X2<>0 then Error := True;
  496.         If X2=0 then If X1<85 then Error := True;
  497.         If Error then begin
  498.           Beep;
  499.           P:=0;
  500.           S:=EntryString;
  501.           GotoXY(X+P,Y);
  502.           Write(S,ConstStr(UnderScore,L-Length(S)));
  503.           Ch := #0;
  504.           FirstChar := True;
  505.         End;
  506.       End;
  507.     Until Ch in Term;
  508.     P := Length(S);
  509.     GotoXY(X+P,Y); Write('':L-P);
  510.     TC := Ch;
  511.   End; { procedure InputStr }
  512.  
  513. PROCEDURE InitializeFiles;
  514.   VAR I:Integer;
  515.       S:Str35;
  516.   Begin
  517.     OpenFile(DFile,DataFileName,SizeOf(DRec));
  518.     If OK then OpenIndex(IFile,IndexFileName,15,1);
  519.     If NOT OK then begin
  520.       Beep;
  521.       GotoXY(5,25);
  522.       Write('Files not found.  Creating new files.');
  523.       MakeFile(DFile,DataFileName,SizeOf(DRec));
  524.       MakeIndex(IFile,IndexFileName,15,1);
  525.     End;
  526.     CloseFile(DFile);
  527.     CloseIndex(IFile);
  528.     If NOT Exist(ClassFileName) then begin
  529.       Rewrite(CFile);
  530.       S:='';
  531.       For I:=1 to 30 do Write(CFile,S);
  532.       Flush(CFile);
  533.       Close(CFile);
  534.     End Else begin
  535.       Reset(CFile);
  536.       For I:=1 to 30 do Read(CFile,ClassList[I]);
  537.       Close(CFile);
  538.     End;
  539.     GotoXY(1,25);ClrEol;
  540.   End; { procedure InitializeFiles }
  541.  
  542. PROCEDURE OpenFiles;
  543.   VAR I:Integer;
  544.   Begin
  545.     OpenFile(DFile,DataFileName,SizeOf(DRec));
  546.     OpenIndex(IFile,IndexFileName,15,1);
  547.     Reset(CFile);
  548.     For I:=1 to 30 do Read(CFile,ClassList[I]);
  549.     Close(CFile);
  550.   End; { procedure OpenFiles }
  551.  
  552. PROCEDURE CloseFiles;
  553.   VAR I:Integer;
  554.   Begin
  555.     CloseFile(DFile);
  556.     CloseIndex(IFile);
  557.     Rewrite(CFile);
  558.     For I:=1 to 30 do Write(CFile,ClassList[I]);
  559.     Flush(CFile);
  560.     Close(CFile);
  561.   End; { procedure CloseFiles }
  562.  
  563. PROCEDURE RebuildKeys;
  564.   VAR
  565.     Fil : file;
  566.     I,N : Integer;
  567.   Begin
  568.     DisplayID;
  569.     If Exist(IndexFileName) then begin
  570.       Assign(Fil,IndexFileName);
  571.       Erase(Fil);
  572.       MakeIndex(IFile,IndexFileName,15,1);
  573.       CloseIndex(IFile);
  574.       OpenFiles;
  575.       For N := 1 to FileLen(DFile)-1 do begin
  576.         GetRec(DFile,N,DRec);
  577.         If DRec.Status=0 then begin
  578.           GotoXY(10,17);
  579.           Write('Reading: ',DRec.LName);ClrEol;
  580.           Key:=DRec.LName;
  581.           For I:=1 to Length(Key) do Key[I]:=Upcase(Key[I]);
  582.           AddKey(IFile,N,Key);
  583.         End;
  584.       End;
  585.       CloseFiles;
  586.     End else begin
  587.       GotoXY(10,17);
  588.       Write(IndexFileName,' not found...');
  589.       Beep;
  590.       Delay(1000);
  591.     End;
  592.   End; { procedure RebuildKeys }
  593.  
  594. PROCEDURE ShowClass;
  595.   VAR S,S2,S3:AnyStr;
  596.       I:Integer;
  597.   Begin
  598.     S:='┌'+ConstStr('─',78)+'┐';             { #218,#196,#191 }
  599.     FastWrite(0,3,HiAt,S);
  600.     S:='│'+ConstStr(' ',78)+'│';             { #179 }
  601.     For I:=1 to 15 do FastWrite(0,I+3,HiAt,S);
  602.     S:='└'+ConstStr('─',78)+'┘';             { #192,#196,#217 }
  603.     FastWrite(0,19,HiAt,S);
  604.     For I:=1 to 15 do begin
  605.       Str(I:2,S2);
  606.       S3:=ClassList[I];
  607.       If S3='' then S3:='<Not Assigned>';
  608.       S:=S2+'-'+S3;
  609.       If S3[1]='<' then FastWrite(3,I+3,LoAt,S) Else FastWrite(3,I+3,HiAt,S);
  610.       Str(I+15:2,S2);
  611.       S3:=ClassList[I+15];
  612.       If S3='' then S3:='<Not Assigned>';
  613.       S:=S2+'-'+S3;
  614.       If S3[1]='<' then FastWrite(43,I+3,LoAt,S) Else FastWrite(43,I+3,HiAt,S);
  615.     End;
  616.   End; { procedure ShowClass }
  617.  
  618. PROCEDURE ShowScreen;
  619.   Begin
  620.     ClrScr;
  621.     FastWrite(0, 0,HiAt,'LITLBOOK');
  622.     FastWrite(9, 0,LoAt,'-- A User-Supported Address Book Program from Jamestown Software');
  623.     FastWrite(0, 1,LoAt,'-------------------------------------------------------------------------------');
  624.     FastWrite(0, 3,LoAt,'     First Name:');
  625.     FastWrite(0, 5,LoAt,'      Last Name:');
  626.     FastWrite(0, 7,LoAt,' Street Address:');
  627.     FastWrite(0, 9,LoAt,'   City / State:');
  628.     FastWrite(0,11,LoAt,'            Zip:');
  629.     FastWrite(0,13,LoAt,'         Phone1:                        Phone2:');
  630.     FastWrite(0,15,LoAt,'          Class:');
  631.     FastWrite(0,17,LoAt,'-- Comment --------------------------------------------------------------------');
  632.     FastWrite(0,21,LoAt,'-------------------------------------------------------------------------------');
  633.   End; { procedure ShowScreen }
  634.  
  635. PROCEDURE SaveRecord;
  636.   VAR I:Integer;
  637.   Begin
  638.     DRec.Status:=0;
  639.     AddRec(DFile,RecNum,DRec);
  640.     Key:=DRec.LName;
  641.     For I:=1 to Length(Key) do Key[I]:=Upcase(Key[I]);
  642.     If OK Then AddKey(IFile,RecNum,Key);
  643.   End; { procedure SaveRecord }
  644.  
  645. PROCEDURE ReplaceRecord;
  646.   VAR I:Integer;
  647.   Begin
  648.     Key:=DRec2.LName;
  649.     For I:=1 to Length(Key) do Key[I]:=Upcase(Key[I]);
  650.     DeleteKey(IFile,RecNum,Key);
  651.     DRec.Status:=0;
  652.     PutRec(DFile,RecNum,DRec);
  653.     Key:=DRec.LName;
  654.     For I:=1 to Length(Key) do Key[I]:=Upcase(Key[I]);
  655.     AddKey(IFile,RecNum,Key);
  656.   End; { procedure ReplaceRecord }
  657.  
  658. PROCEDURE ShowRecord;
  659.   VAR S:AnyStr;
  660.       I,J:Integer;
  661.   Begin
  662.     With DRec do begin
  663.       S:=FName;
  664.       S:=S+ConstStr(' ',15-Length(S));
  665.       FastWrite(17, 3,HiAt,S);
  666.       If MenuChoice='2' then begin
  667.         GotoXY(60,4);
  668.         ClrEol;
  669.         Write('Rec.No.: ',RecNum);
  670.       End;
  671.       GotoXY(60,5);Write(UsedRecs(DFile),' records in use');
  672.       S:=LName;
  673.       S:=S+ConstStr(' ',30-Length(S));
  674.       FastWrite(17, 5,HiAt,S);
  675.       S:=Address;
  676.       S:=S+ConstStr(' ',25-Length(S));
  677.       FastWrite(17, 7,HiAt,S);
  678.       S:=CityState;
  679.       S:=S+ConstStr(' ',25-Length(S));
  680.       FastWrite(17, 9,HiAt,S);
  681.       S:=Zip;
  682.       S:=S+ConstStr(' ',10-Length(S));
  683.       FastWrite(17,11,HiAt,S);
  684.       S:=Phone1;
  685.       S:=S+ConstStr(' ',12-Length(S));
  686.       FastWrite(17,13,HiAt,S);
  687.       S:=Phone2;
  688.       S:=S+ConstStr(' ',12-Length(S));
  689.       FastWrite(49,13,HiAt,S);
  690.       S:=Class;
  691.       Val(Class,I,J);
  692.       If (J<>0) or (I=0) or (S='') or
  693.          ((J=0) and (I in [1..30])) and (ClassList[I]='')
  694.          then S:=S+ConstStr(' ',2-Length(S))+'  <Not Assigned>'
  695.       Else S:=S+ConstStr(' ',2-Length(S))+'  '+ClassList[I];
  696.       S:=S+ConstStr(' ',40-Length(S));
  697.       FastWrite(17,15,HiAt,S);
  698.       S:=Comment;
  699.       S:=S+ConstStr(' ',79-Length(S));
  700.       FastWrite(0,19,HiAt,S);
  701.     End;
  702.   End; { procedure ShowRecord }
  703.  
  704. PROCEDURE Message(N:Integer;S:AnyStr);
  705.   VAR I:Integer;
  706.   Begin
  707.     S:=S+ConstStr(' ',80-Length(S));
  708.     If N>3 then begin
  709.       For I:=22 to 24 do FastWrite(0, I,HiAt,ConstStr(' ',80));
  710.       N:=N-3;
  711.       If N>3 then N:=2;
  712.     End;
  713.     FastWrite(0, 21+N,HiAt,S);
  714.   End; { procedure Message }
  715.  
  716. PROCEDURE EnterData;
  717.   VAR S,S1 : AnyStr;
  718.       I,J,N,
  719.       Line : Integer;
  720.       Done : Boolean;
  721.       ExitSet : CharSet;
  722.       TC      : Char;
  723.   Begin
  724.     NormVideo;
  725.     Done:=False;
  726.     Line:=1;
  727.     RestoreCursor;
  728.     If MenuChoice='1' then FillChar(DRec,SizeOf(DRec),0) Else DRec2:=DRec;
  729.     If MenuChoice='1' then ShowRecord;
  730.     With DRec do begin
  731.       GotoXY(60,5);Write(UsedRecs(DFile),' records in use');
  732.       Repeat
  733.         ExitSet:=[#13,^E,^X,^Z];
  734.         If MenuChoice='1' then Message(6,'Adding a new record to LITLBOOK... Pres <F10> when done.  <ESC>=Oops!')
  735.           Else Message(6,'Editing a LITLBOOK record... Pres <F10> when done.  <ESC>=Oops!');
  736.         RestoreCursor;
  737.         Case Line of
  738.           1 : Begin
  739.                 Message(1,'Enter the FIRST NAME (15 character limit).');
  740.                 S:=FName;
  741.                 InputStr(S,15,18,4,Af,ExitSet,TC);
  742.                 FName:=S;
  743.               End;
  744.           2 : Begin
  745.                 Message(1,'Enter the LAST NAME or COMPANY NAME (30 character limit).');
  746.                 S:=LName;
  747.                 InputStr(S,30,18,6,Af,ExitSet,TC);
  748.                 LName:=S;
  749.               End;
  750.           3 : Begin
  751.                 Message(1,'Enter the ADDRESS (25 character limit).');
  752.                 S:=Address;
  753.                 InputStr(S,25,18,8,Af,ExitSet,TC);
  754.                 Address:=S;
  755.               End;
  756.           4 : Begin
  757.                 Message(1,'Enter the CITY and STATE (25 character limit).');
  758.                 S:=CityState;
  759.                 InputStr(S,25,18,10,Af,ExitSet,TC);
  760.                 CityState:=S;
  761.               End;
  762.           5 : Begin
  763.                 Message(1,'Enter the ZIP CODE (10 character limit).');
  764.                 S:=Zip;
  765.                 InputStr(S,10,18,12,Nf,ExitSet,TC);
  766.                 Zip:=S;
  767.               End;
  768.           6 : Begin
  769.                 Message(1,'Enter PHONE NUMBER ONE (12 character limit).');
  770.                 S:=Phone1;
  771.                 InputStr(S,12,18,14,Nf,ExitSet,TC);
  772.                 Phone1:=S;
  773.               End;
  774.           7 : Begin
  775.                 Message(1,'Enter the PHONE NUMBER TWO (12 character limit).');
  776.                 S:=Phone2;
  777.                 InputStr(S,12,50,14,Nf,ExitSet,TC);
  778.                 Phone2:=S;
  779.               End;
  780.           8 : Repeat
  781.                 ExitSet:=[#13,^E,^X,^Z,^Q];
  782.                 Message(1,'Enter a CLASSIFICATION (Press <F1> for List).');
  783.                 S:=Class;
  784.                 GotoXY(18,16);
  785.                 ClrEol;
  786.                 InputStr(S,2,18,16,Nf,ExitSet,TC);
  787.                 Val(S,I,J);
  788.                 If (J<>0) or (S='') or (NOT (I in [1..30])) then S:='0';
  789.                 Class:=S;
  790.                 If (TC=^Q) or ((S<>'0') and (ClassList[I]='')) then begin
  791.                   SaveScreen;
  792.                   ShowClass;
  793.                   If TC=^Q then begin
  794.                     Repeat
  795.                       ExitSet:=[#13];
  796.                       Message(5,'Select CLASSIFICATION: ');
  797.                       S1:='';
  798.                       InputStr(S1,2,24,24,Nf,ExitSet,TC);
  799.                       Val(S1,I,J);
  800.                     Until (I in [1..30]) and (J=0);
  801.                     If S1<>'' then Class:=S1;
  802.                   End;
  803.                   If ClassList[I]='' then begin
  804.                     N:=I;
  805.                     ExitSet:=[#13];
  806.                     Str(N,S);
  807.                     S:='Enter Classification Name for #'+S+': ';
  808.                     Message(5,S);
  809.                     S:='';
  810.                     InputStr(S,35,36,24,Af,ExitSet,TC);
  811.                     ClassList[N]:=S;
  812.                   End;
  813.                   RestoreScreen;
  814.                 End;
  815.                 If Class<>'0' then begin
  816.                   GotoXY(18,16);
  817.                   Write(Class);
  818.                   GotoXY(22,16);
  819.                   Val(Class,I,J);
  820.                   Write(ClassList[I]);
  821.                 End;
  822.               Until TC in [#13,^E,^X,^Z];
  823.           9 : Begin
  824.                 Message(1,'Enter a COMMENT (79 character limit).   Press <Ctrl-D> for todays date.');
  825.                 ExitSet:=[#13,^E,^X,^Z,^D];
  826.                 Repeat
  827.                   S:=Comment;
  828.                   InputStr(S,79,1,20,Af,ExitSet,TC);
  829.                   If TC=^D then S:=S+TDate+' ';
  830.                   Comment:=S;
  831.                 Until TC in [#13,^E,^X,^Z];
  832.               End;
  833.         End;
  834.         If TC in [#13,^X] then Line:=Line+1;
  835.         If TC = ^E then Line:=Line-1;
  836.         If (TC=^Z) or (Line=10) then begin
  837.           HideCursor;
  838.           Message(5,'Do you wish to continue working with this record?  Y/N');
  839.           Beep;
  840.           If NOT YES then begin
  841.             Done:=True;
  842.             Message(5,'Save this record?  Y/N');
  843.             If YES then begin
  844.               If MenuChoice='1' then SaveRecord else ReplaceRecord;
  845.             End;
  846.             If MenuChoice='1' then begin
  847.               Message(5,'Another entry?  Y/N');
  848.               If YES then EnterData;
  849.             End;
  850.           End;
  851.         End;
  852.         If Line<1 then Line:=9;
  853.         If Line>9 then Line:=1;
  854.       Until Done;
  855.     End; { with }
  856.     Message(5,'Closing files...');
  857.   End; { procedure EnterData }
  858.  
  859. PROCEDURE BrowseEdit;
  860.   VAR S    : AnyStr;
  861.       I    : Integer;
  862.       TC      : Char;
  863.  
  864.   PROCEDURE EnterSearch;
  865.     Begin
  866.       SaveScreen;
  867.       If ParamRead then begin
  868.         FastWrite(15,16,HiAt,'┌──────────────────────────────────────────────────┐');
  869.         FastWrite(15,17,HiAt,'│                                                  │');
  870.         FastWrite(15,18,HiAt,'│                                                  │');
  871.         FastWrite(15,19,HiAt,'│                                                  │');
  872.         FastWrite(15,20,HiAt,'└──────────────────────────────────────────────────┘');
  873.         GotoXY(17,19);Write(' Search for: ');
  874.         S:='';
  875.         RestoreCursor;
  876.         InputStr(S,15,30,19,Af,[#13],TC);
  877.         HideCursor;
  878.         Key:=S;
  879.       End Else begin
  880.         Key:=ParamStr(1);
  881.         ParamRead:=True;
  882.       End;
  883.       For I:=1 to Length(Key) do Key[I]:=Upcase(Key[I]);
  884.       SearchKey(IFile,RecNum,Key);
  885.       If NOT OK then begin
  886.         S:='No Record found...';
  887.         S:=S+ConstStr(' ',79-Length(S));
  888.         FastWrite(0,0,HiAt,S);
  889.       End;
  890.       GetRec(DFile,RecNum,DRec);
  891.       RestoreScreen;
  892.       ShowRecord;
  893.     End; { procedure EnterSearch }
  894.  
  895.   Begin
  896.     If UsedRecs(DFile)=0 then begin
  897.       Beep;
  898.       Message(5,' No active records... returning to menu');
  899.       Delay(2000);
  900.       Exit;
  901.     End;
  902.     Message(4,'Browsing records in LITLBOOK database...');
  903.     Message(2,'Press  <Q> Quit  <P> Previous  <N> Next  <S> Search');
  904.     Message(3,'       <E> Edit  <D> Delete');
  905.     HideCursor;
  906.     EnterSearch;
  907.     Repeat
  908.       Repeat
  909.         Read(Kbd,Ch);
  910.         Ch:=Upcase(Ch);
  911.         If NOT (Ch in ['Q','P','N','S','E','D']) then Boop;
  912.       Until Ch in ['Q','P','N','S','E','D'];
  913.       FastWrite(0, 0,HiAt,'LITLBOOK  ');
  914.       FastWrite(9, 0,LoAt,'-- A User-Supported Address Book Program from Jamestown Software');
  915.       Case Ch of
  916.         'Q' :;
  917.         'P' : Begin
  918.                 PrevKey(IFile,RecNum,Key);
  919.                 If NOT OK then begin
  920.                   S:='Last Record...';
  921.                   S:=S+ConstStr(' ',79-Length(S));
  922.                   FastWrite(0,0,HiAt,S);
  923.                   PrevKey(IFile,RecNum,Key);
  924.                 End;
  925.                 GetRec(DFile,RecNum,DRec);
  926.                 ShowRecord;
  927.               End;
  928.         'N' : Begin
  929.                 NextKey(IFile,RecNum,Key);
  930.                 If NOT OK then begin
  931.                   S:='First Record...';
  932.                   S:=S+ConstStr(' ',79-Length(S));
  933.                   FastWrite(0,0,HiAt,S);
  934.                   NextKey(IFile,RecNum,Key);
  935.                 End;
  936.                 GetRec(DFile,RecNum,DRec);
  937.                 ShowRecord;
  938.               End;
  939.         'S' : Begin
  940.                 EnterSearch;
  941.               End;
  942.         'E' : Begin
  943.                 EnterData;
  944.                 HideCursor;
  945.                 Message(4,'Browsing records in LITLBOOK database...');
  946.                 Message(2,'Press  <Q> Quit  <P> Previous  <N> Next  <S> Search');
  947.                 Message(3,'       <E> Edit  <D> Delete');
  948.                 GetRec(DFile,RecNum,DRec);
  949.                 ShowRecord;
  950.               End;
  951.         'D' : Begin
  952.                 SaveScreen;
  953.                 FastWrite(25,16,HiAt,'┌───────────────────────────┐');
  954.                 FastWrite(25,17,HiAt,'│                           │');
  955.                 FastWrite(25,18,HiAt,'└───────────────────────────┘');
  956.                 TextColor(LightGray+Blink);
  957.                 GotoXY(29,18);
  958.                 Beep;
  959.                 Write('Delete... Are you SURE?');
  960.                 NormVideo;
  961.                 If YES then begin
  962.                   RestoreScreen;
  963.                   DeleteKey(IFile,RecNum,Key);
  964.                   DeleteRec(DFile,RecNum);
  965.                   SearchKey(IFile,RecNum,Key);
  966.                   GetRec(DFile,RecNum,DRec);
  967.                   ShowRecord;
  968.                 End Else RestoreScreen;
  969.               End;
  970.       End;
  971.     Until Ch='Q';
  972.     Message(5,'Closing files...');
  973.   End; { procedure BrowseEdit }
  974.  
  975. PROCEDURE Inp;
  976.   VAR N,I,J:Integer;
  977.       S:AnyStr;
  978.       TC:Char;
  979.       YesToo:Boolean;
  980.       Done:Boolean;
  981.   Begin
  982.     DisplayID;
  983.     HideCursor;
  984.     ClassSort:=False;
  985.     ZipSort:=False;
  986.     FastWrite(0,16,HiAt,CenterStr('Sort Method:  <A>lphabetically   or by <C>lassification',79));
  987.     Repeat
  988.       Read(Kbd,Ch);
  989.       Ch:=Upcase(Ch);
  990.       If NOT (Ch in ['A','C']) then Boop;
  991.     Until Ch in ['A','C'];
  992.     If ReportChoice='4' then begin
  993.       FastWrite(0,16,HiAt,CenterStr('Print labels in Zip Code order?  Y/N',79));
  994.       If YES then ZipSort:=True;
  995.     End;
  996.     FastWrite(0,16,HiAt,CenterStr(' ',79));
  997.     If Ch='C' then begin
  998.       ClassSort:=True;
  999.       FastWrite(0,16,HiAt,CenterStr('Print all classifications?  Y/N',79));
  1000.       If YES then begin
  1001.         FastWrite(0,16,HiAt,CenterStr(' ',79));
  1002.         For N:=1 to FileLen(DFile)-1 do begin
  1003.           GetRec(DFile,N,DRec);
  1004.           If DRec.Status=0 then begin
  1005.             GotoXY(10,17);
  1006.             Write('Reading: ',DRec.LName);ClrEol;
  1007.             SortRelease(DRec);
  1008.           End;
  1009.         End;
  1010.       End Else begin
  1011.         GotoXY(1,17);ClrEol;
  1012.         SaveScreen;
  1013.         ClrScr;
  1014.         Repeat
  1015.           ShowClass;
  1016.           GotoXY(30,23);Write('Classification: ');
  1017.           S:='';
  1018.           RestoreCursor;
  1019.           InputStr(S,2,46,23,Nf,[#13],TC);
  1020.           HideCursor;
  1021.           Val(S,I,J);
  1022.         Until (I in [1..30]) and (J=0);
  1023.         RestoreScreen;
  1024.         For N:=1 to FileLen(DFile)-1 do begin
  1025.           GetRec(DFile,N,DRec);
  1026.           If DRec.Status=0 then begin
  1027.             GotoXY(10,17);
  1028.             Write('Reading: ',DRec.LName);ClrEol;
  1029.           End;
  1030.           If (DRec.Status=0) and (DRec.Class=S) then SortRelease(DRec);
  1031.         End;
  1032.       End;
  1033.     End Else For N:=1 to FileLen(DFile)-1 do begin
  1034.       GetRec(DFile,N,DRec);
  1035.       If DRec.Status=0 then begin
  1036.         GotoXY(10,17);
  1037.         Write('Reading: ',DRec.LName);ClrEol;
  1038.         SortRelease(DRec);
  1039.       End;
  1040.     End;
  1041.     LastNameFirst:=False;
  1042.     If ReportChoice='5' then begin
  1043.       FastWrite(0,16,HiAt,CenterStr('Print Last Name FIRST?   Y/N',79));
  1044.       If YES then LastNameFirst:=True;
  1045.     End;
  1046.     FastWrite(0,16,HiAt,CenterStr('Print to:   <S>creen  <P>rinter  <D>isk',79));
  1047.     Repeat
  1048.       Read(Kbd,Ch);
  1049.       Ch:=Upcase(Ch);
  1050.       If NOT (Ch in ['S','P','D']) then Boop;
  1051.     Until Ch in ['S','P','D'];
  1052.     Case Ch of
  1053.       'S' : Begin
  1054.               HardCopy:=False;
  1055.             End;
  1056.       'P' : Begin
  1057.               FastWrite(0,16,HiAt,CenterStr(' ',79));
  1058.               HardCopy:=True;
  1059.               If NOT PrReady then PrinterWarning;
  1060.               If Abort then HardCopy:=False;
  1061.               If HardCopy then PrinterSet;
  1062.               If Abort then HardCopy:=False;
  1063.             End;
  1064.       'D' : Begin
  1065.               Repeat
  1066.                 FastWrite(0,16,HiAt,CenterStr(' ',79));
  1067.                 Done:=False;
  1068.                 S:='';
  1069.                 GotoXY(10,17);
  1070.                 Write('File Name:');
  1071.                 RestoreCursor;
  1072.                 InputStr(S,40,21,17,Af,[#13],TC);
  1073.                 AsciiName:=S;
  1074.                 HideCursor;
  1075.                 AsciiFile:=False;
  1076.                 HardCopy:=False;
  1077.                 If S<>'' then begin
  1078.                   If Exist(S) then begin
  1079.                     FastWrite(0,16,HiAt,CenterStr('File Exists... Overwrite?  Y/N',79));
  1080.                     If YES then AsciiFile:=True;
  1081.                   End else AsciiFile:=True;
  1082.                 End;
  1083.               Until (S='') or (AsciiFile=True);
  1084.               If S='' then Ch:='S';
  1085.             End;
  1086.     End;
  1087.     If NOT AsciiFile then begin
  1088.       If HardCopy then Assign(OutFile,'LST:') else Assign(OutFile,'CON:');
  1089.     End;
  1090.     If NOT Hardcopy then ClrScr;
  1091.   End; { procedure Inp }
  1092.  
  1093. FUNCTION Less;
  1094.   VAR First  : DataRecord Absolute X;
  1095.       Second : DataRecord Absolute Y;
  1096.       I,J,K  : Integer;
  1097.   Begin
  1098.     Val(First.Class,I,K);
  1099.     If (K<>0) or (I<0) then I:=0;
  1100.     Val(Second.Class,J,K);
  1101.     If (K<>0) or (J<0) then J:=0;
  1102.     If ZipSort and ClassSort then begin
  1103.       Less:=(I<J) or
  1104.             ((I=J) and (First.Zip<Second.Zip)) or
  1105.             ((I=J) and (First.Zip=Second.Zip) and (First.LName<Second.LName));
  1106.     End Else If ZipSort then begin
  1107.       Less:=(First.Zip<Second.Zip) or
  1108.             ((First.Zip=Second.Zip) and (First.LName<Second.LName));
  1109.     End Else If ClassSort then begin
  1110.       Less:=(I<J) or
  1111.             ((I=J) and (First.LName<Second.LName));
  1112.     End Else Less:=First.LName<Second.LName;
  1113.   End; { function Less }
  1114.  
  1115. PROCEDURE OutP;
  1116.   VAR S,S1,S2:AnyStr;
  1117.       I,J,Lines,Page:Integer;
  1118.       Test:String[2];
  1119.       TestInt,ClassInt,K:Integer;
  1120.       Ch:Char;
  1121.  
  1122.   FUNCTION Continue: Boolean;
  1123.     Begin
  1124.       SaveScreen;
  1125.       FastWrite(31,16,HiAt,'┌───────────────┐');
  1126.       FastWrite(31,17,HiAt,'│               │');
  1127.       FastWrite(31,18,HiAt,'└───────────────┘');
  1128.       Read(Kbd,Ch);
  1129.       Boop;
  1130.       TextColor(LightGray+Blink);
  1131.       GotoXY(34,18);
  1132.       Write('Continue? Y/N');
  1133.       NormVideo;
  1134.       If YES then Continue:=True else Continue:=False;
  1135.       RestoreScreen;
  1136.     End; { function Continue }
  1137.  
  1138.     FUNCTION ClearComma(S:AnyStr): AnyStr;
  1139.       VAR P:Integer;
  1140.       Begin
  1141.         While Pos(',',S)>0 Delete(S,Pos(',',S),1);
  1142.         ClearComma:=S;
  1143.       End; { function ClearComma }
  1144.  
  1145.   Begin
  1146.     If Abort then Exit;
  1147.     Lines:=0;
  1148.     Test:='99';
  1149.     Page:=1;
  1150.     If SortEOS then begin
  1151.       Beep;
  1152.       FastWrite(0,16,HiAt,CenterStr('No records meeting sort criteria...',79));
  1153.       Delay(1000);
  1154.       Exit;
  1155.     End;
  1156.     If AsciiFile then begin
  1157.       Assign(OutFile,AsciiName);
  1158.       {$I-}
  1159.       ReWrite(OutFile);
  1160.       {$I+}
  1161.       If IOResult<>0 then begin
  1162.         Close(OutFile);
  1163.         Boop;
  1164.         FastWrite(0,16,HiAt,CenterStr('File can not be opened...',79));
  1165.         Delay(1000);
  1166.         Exit;
  1167.       End;
  1168.       FastWrite(0,16,HiAt,CenterStr('File Format:  <P>rinter          <C>omma Delimited',79));
  1169.       FastWrite(0,17,HiAt,CenterStr('              <S>eparate Lines   <F>ixed Length   ',79));
  1170.       Repeat
  1171.         Read(Kbd,Ch);
  1172.         Ch:=Upcase(Ch);
  1173.         If NOT (Ch in ['P','F','C','S']) then Boop;
  1174.       Until Ch in ['P','F','C','S'];
  1175.       ClrScr;
  1176.       If Ch='C' then begin
  1177.         While NOT SortEOS do begin
  1178.           SortReturn(DRec);
  1179.           GotoXY(10,17);
  1180.           Write('Printing: ',DRec.LName);ClrEol;
  1181.           Write(OutFile,ClearComma(DRec.FName),',');
  1182.           Write(OutFile,ClearComma(DRec.LName),',');
  1183.           Write(OutFile,ClearComma(DRec.Address),',');
  1184.           Write(OutFile,ClearComma(DRec.CityState),',');
  1185.           Write(OutFile,ClearComma(DRec.Zip),',');
  1186.           Write(OutFile,ClearComma(DRec.Phone1),',');
  1187.           Write(OutFile,ClearComma(DRec.Phone2),',');
  1188.           Val(DRec.Class,I,J);
  1189.           If (J<>0) or (I=0) or
  1190.              ((J=0) and (I in [1..30])) and (ClassList[I]='')
  1191.              then S:='<Not Assigned>'
  1192.           Else S:=ClassList[I];
  1193.           Write(OutFile,ClearComma(S),',');
  1194.           WriteLn(OutFile,ClearComma(DRec.Comment));
  1195.         End;
  1196.         Flush(OutFile);
  1197.         Close(OutFile);
  1198.         Exit;
  1199.       End;
  1200.       If Ch='F' then begin
  1201.         While NOT SortEOS do begin
  1202.           SortReturn(DRec);
  1203.           GotoXY(10,17);
  1204.           Write('Printing: ',DRec.LName);ClrEol;
  1205.           Write(OutFile,DRec.FName,ConstStr(' ',15-Length(DRec.FName)));
  1206.           Write(OutFile,DRec.LName,ConstStr(' ',30-Length(DRec.LName)));
  1207.           Write(OutFile,DRec.Address,ConstStr(' ',25-Length(DRec.Address)));
  1208.           Write(OutFile,DRec.CityState,ConstStr(' ',25-Length(DRec.CityState)));
  1209.           Write(OutFile,DRec.Zip,ConstStr(' ',10-Length(DRec.Zip)));
  1210.           Write(OutFile,DRec.Phone1,ConstStr(' ',12-Length(DRec.Phone1)));
  1211.           Write(OutFile,DRec.Phone2,ConstStr(' ',12-Length(DRec.Phone2)));
  1212.           Val(DRec.Class,I,J);
  1213.           If (J<>0) or (I=0) or
  1214.              ((J=0) and (I in [1..30])) and (ClassList[I]='')
  1215.              then S:='<Not Assigned>'
  1216.           Else S:=ClassList[I];
  1217.           Write(OutFile,S,ConstStr(' ',35-Length(S)));
  1218.           WriteLn(OutFile,DRec.Comment,ConstStr(' ',79-Length(DRec.Comment)));
  1219.         End;
  1220.         Flush(OutFile);
  1221.         Close(OutFile);
  1222.         Exit;
  1223.       End;
  1224.       If Ch='S' then begin
  1225.         While NOT SortEOS do begin
  1226.           SortReturn(DRec);
  1227.           GotoXY(10,17);
  1228.           Write('Printing: ',DRec.LName);ClrEol;
  1229.           WriteLn(OutFile,DRec.FName);
  1230.           WriteLn(OutFile,DRec.LName);
  1231.           WriteLn(OutFile,DRec.Address);
  1232.           WriteLn(OutFile,DRec.CityState);
  1233.           WriteLn(OutFile,DRec.Zip);
  1234.           WriteLn(OutFile,DRec.Phone1);
  1235.           WriteLn(OutFile,DRec.Phone2);
  1236.           Val(DRec.Class,I,J);
  1237.           If (J<>0) or (I<=0) or
  1238.              ((J=0) and (I in [1..30])) and (ClassList[I]='')
  1239.              then S:='<Not Assigned>'
  1240.           Else S:=ClassList[I];
  1241.           WriteLn(OutFile,S);
  1242.           WriteLn(OutFile,DRec.Comment);
  1243.         End;
  1244.         Flush(OutFile);
  1245.         Close(OutFile);
  1246.         Exit;
  1247.       End;
  1248.     End;
  1249.     While NOT SortEOS do begin
  1250.       SortReturn(DRec);
  1251.       If HardCopy or AsciiFile then begin
  1252.         GotoXY(10,17);
  1253.         Write('Printing: ',DRec.LName);ClrEol;
  1254.       End;
  1255.       If ReportChoice='4' then begin
  1256.         WriteLn(OutFile ,ConstStr(' ',30),DRec.Class);
  1257.         If DRec.FName<>'' then S:=DRec.FName+' '+DRec.LName else S:=DRec.LName;
  1258.         WriteLn(OutFile,Copy(S,1,32));
  1259.         WriteLn(OutFile,DRec.Address);
  1260.         S:=DRec.CityState+' '+DRec.Zip;
  1261.         WriteLn(OutFile,S);
  1262.         WriteLn(OutFile);
  1263.         WriteLn(OutFile);
  1264.         If Keypressed then if NOT Continue then Exit;
  1265.       End Else Begin
  1266.         Val(Test,TestInt,K);
  1267.         If (K<>0) or (TestInt<0) then TestInt:=0;
  1268.         Val(DRec.Class,ClassInt,K);
  1269.         If (K<>0) or (ClassInt<0) then ClassInt:=0;
  1270.         If ( ((TestInt<>ClassInt) and ClassSort) or (Lines=0) ) and (HardCopy or AsciiFile) then begin
  1271.           If ClassSort then begin
  1272.             If Lines<>0 then WriteLn(OutFile);
  1273.             Val(DRec.Class,I,J);
  1274.             If (J<>0) or (I=0) or (ClassList[I]='') or
  1275.                ((J=0) and (I in [1..30])) and (ClassList[I]='')
  1276.                then S:='<Not Assigned>'
  1277.             Else S:=ClassList[I];
  1278.             S:=S+' ('+DRec.Class+')';
  1279.             Write(OutFile,S);
  1280.             I:=Length(S);
  1281.           End else begin
  1282.             Write(OutFile,'Alpha listing of ALL records');
  1283.             I:=28;
  1284.           End;
  1285.           If (Lines=0) and (Test<>'99') and
  1286.              (((TestInt=ClassInt) and ClassSort) or (NOT ClassSort))
  1287.           then begin
  1288.             Write(OutFile,' (cont.)');
  1289.             I:=I+8;
  1290.           End;
  1291.           Write(OutFile,'... LITLBOOK as of ',TDate);
  1292.           I:=I+27;
  1293.           If (I<71) and (Lines=0) then WriteLn(OutFile,ConstStr(' ',71-I),'Page',Page:3)
  1294.             else WriteLn(OutFile);
  1295.           WriteLn(OutFile,ConstStr('-',78));
  1296.           WriteLn(OutFile);
  1297.           If (Lines<>0) or (Test='99') or
  1298.              ((Lines=0) and (TestInt<>ClassInt)) then Test:=DRec.Class;
  1299.           If Lines=0 then begin
  1300.             Lines:=3;
  1301.             Page:=Page+1;
  1302.           End else Lines:=Lines+4;
  1303.         End;
  1304.         If LastNameFirst then begin
  1305.           For I:=1 to Length(DRec.LName) do DRec.LName[I]:=Upcase(DRec.LName[I]);
  1306.           If DRec.FName='' then S:=DRec.LName else S:=DRec.LName+', '+DRec.FName;
  1307.         End else begin
  1308.           If DRec.FName<>'' then S:=DRec.FName+' '+DRec.LName else S:=DRec.LName;
  1309.         End;
  1310.         S:=S+ConstStr('.',78-(Length(S)+Length(DRec.Phone1)))+' '+DRec.Phone1;
  1311.         WriteLn(OutFile,S);
  1312.         S:='    ';
  1313.         If DRec.Address<>'' then S:=S+DRec.Address+', ';
  1314.         S:=S+DRec.CityState+'  '+DRec.Zip;
  1315.         If DRec.Phone2<>'' then
  1316.           S:=S+ConstStr(' ',78-(Length(S)+Length(DRec.Phone2)))+' '+DRec.Phone2;
  1317.         If S<>'    ' then begin
  1318.           WriteLn(OutFile,S);
  1319.           Lines:=Lines+1;
  1320.         End;
  1321.         Lines:=Lines+1;
  1322.         If DRec.Comment<>'' then begin
  1323.           S:=DRec.Comment;
  1324.           S1:=Copy(S,1,70);
  1325.           I:=Length(S1);
  1326.           If I=70 then While (S1[I]<>' ') and (I<>0) do I:=I-1;
  1327.           S2:=Copy(S1,1,I);
  1328.           Delete(S,1,I);
  1329.           If S2<>''then begin
  1330.             WriteLn(OutFile,'    ',S2);
  1331.             Lines:=Lines+1;
  1332.           End;
  1333.           If S<>''then begin
  1334.             WriteLn(OutFile,'    ',S);
  1335.             Lines:=Lines+1;
  1336.           End;
  1337.         End;
  1338.         If NOT ClassSort then begin
  1339.           Val(DRec.Class,I,J);
  1340.           If (J<>0) or (I=0) or
  1341.              ((J=0) and (I in [1..30])) and (ClassList[I]='')
  1342.              then S:='<Not Assigned>' Else S:=ClassList[I];
  1343.           S:='('+S+')';
  1344.           WriteLn(OutFile,'        ',S);
  1345.           Lines:=Lines+1;
  1346.         End;
  1347.         If Lines>=54 then begin
  1348.           If HardCopy then Write(OutFile,#12);
  1349.           If AsciiFile then Write(OutFile,#13,#10,#13,#10,#13,#10);
  1350.           Lines:=0;
  1351.         End;
  1352.         If Keypressed then if NOT Continue then begin
  1353.           If AsciiFile then Close(OutFile);
  1354.           Exit;
  1355.         End;
  1356.       End;
  1357.     End;
  1358.     If (Lines<>0) and HardCopy then Write(OutFile,#12);
  1359.     Close(OutFile);
  1360.     If NOT (HardCopy or AsciiFile) then begin
  1361.       WriteLn;
  1362.       Write('Press any key to continue...');
  1363.       Beep;
  1364.       Read(Kbd,Ch);
  1365.     End;
  1366.     If AsciiFile then Close(OutFile);
  1367.   End; { procedure OutP }
  1368.  
  1369. PROCEDURE ChangeClass;
  1370.   VAR S   : AnyStr;
  1371.       I,J : Integer;
  1372.       TC  : Char;
  1373.       Done    : Boolean;
  1374.       ExitSet : CharSet;
  1375.   Begin
  1376.     SaveScreen;
  1377.     RestoreCursor;
  1378.     ClrScr;
  1379.     Done:=False;
  1380.     Repeat
  1381.       ShowClass;
  1382.       Repeat
  1383.         ExitSet:=[#13];
  1384.         Message(5,'Select CLASSIFICATION:       (0 to quit) ');
  1385.         S:='';
  1386.         InputStr(S,2,24,24,Nf,ExitSet,TC);
  1387.         Val(S,I,J);
  1388.         If S='0' then Done:=True;
  1389.       Until ((I in [1..30]) and (J=0) and (S<>'')) or Done;
  1390.       If NOT Done then begin
  1391.         Str(I,S);
  1392.         S:='Enter Classification Name for #'+S+': ';
  1393.         Message(5,S);
  1394.         S:=ClassList[I];
  1395.         InputStr(S,35,36,24,Af,ExitSet,TC);
  1396.         ClassList[I]:=S;
  1397.       End;
  1398.     Until Done;
  1399.     HideCursor;
  1400.     RestoreScreen;
  1401.   End; { procedure ChangeClass }
  1402.  
  1403. PROCEDURE ReportMenu;
  1404.   CONST N=24;
  1405.   VAR I:Integer;
  1406.       S:AnyStr;
  1407.   Begin
  1408.     ClrScr;
  1409.     DisplayID;
  1410.     Beep;
  1411.     FastWrite(N,09,HiAt,'4 -- PRINT labels');
  1412.     FastWrite(N,11,HiAt,'5 -- PRINT general listing');
  1413.     FastWrite(N,13,HiAt,'6 -- PRINT classification summary');
  1414.     FastWrite(N,15,HiAt,'7 -- CHANGE classification name');
  1415.     FastWrite(N,17,HiAt,'8 -- Rebuild keys');
  1416.     FastWrite(N,19,LoAt,'0 -- Return to Main Menu');
  1417.     FastWrite(N,22,LoAt,'Press your selection number...');
  1418.     HideCursor;
  1419.     Repeat
  1420.       Read(Kbd,ReportChoice);
  1421.       ReportChoice:=Upcase(ReportChoice);
  1422.       If NOT (ReportChoice in ['4'..'8','0']) then boop;
  1423.     Until ReportChoice in ['4'..'8','0'];
  1424.     Abort:=False;
  1425.     AsciiFile:=False;
  1426.     Case ReportChoice of
  1427.       '4' : Begin
  1428.               OpenFiles;
  1429.               I:=TurboSort(SizeOf(DRec));
  1430.               CloseFiles;
  1431.             End;
  1432.       '5' : Begin
  1433.               OpenFiles;
  1434.               I:=TurboSort(SizeOf(DRec));
  1435.               CloseFiles;
  1436.             End;
  1437.       '6' : Begin
  1438.               If NOT PrReady then PrinterWarning;
  1439.               If Abort then Exit;
  1440.               PrinterSet;
  1441.               If Abort then Exit;
  1442.               OpenFiles;
  1443.               WriteLn(Lst,'Classifications in LITLBOOK as of ',TDate);
  1444.               WriteLn(Lst,ConstStr('-',79));
  1445.               WriteLn(Lst,' ');
  1446.               For I:=1 to 30 do begin
  1447.                 GotoXY(1,25);
  1448.                 Write(I:2,' - ',ClassList[I]);ClrEol;
  1449.                 WriteLn(Lst,I:2,' - ',ClassList[I]);
  1450.               End;
  1451.               WriteLn(Lst,#12);
  1452.               CloseFiles;
  1453.             End;
  1454.       '7' : Begin
  1455.               OpenFiles;
  1456.               ChangeClass;
  1457.               CloseFiles;
  1458.             End;
  1459.       '8' : Begin
  1460.               RebuildKeys;
  1461.             End;
  1462.     End; { case }
  1463.   End; { procedure ReportMenu }
  1464.  
  1465. PROCEDURE Menu;
  1466.   CONST N=20;
  1467.   Begin
  1468.     ClrScr;
  1469.     DisplayID;
  1470.     FastWrite(N,10,HiAt,'1 -- ADD new information');
  1471.     FastWrite(N,12,HiAt,'2 -- BROWSE/EDIT record information');
  1472.     FastWrite(N,14,HiAt,'3 -- PRINT record information / UTILITIES');
  1473.     FastWrite(N,17,LoAt,'0 -- QUIT and return to DOS');
  1474.     FastWrite(N,21,LoAt,'Press your selection number...');
  1475.     LowVideo;
  1476.     GotoXY(1,25);ClrEol;
  1477.     Write(FreeSpace:10:0,' left on ',EDrive);
  1478.     NormVideo;
  1479.     Repeat
  1480.       HideCursor;
  1481.       Repeat
  1482.         Read(Kbd,MenuChoice);
  1483.         MenuChoice:=Upcase(MenuChoice);
  1484.         If NOT (MenuChoice in ['1'..'3','0']) then boop;
  1485.       Until MenuChoice in ['1'..'3','0'];
  1486.       AsciiFile:=False;
  1487.       Case MenuChoice of
  1488.         '1' : Begin
  1489.                 ShowScreen;
  1490.                 OpenFiles;
  1491.                 EnterData;
  1492.                 CloseFiles;
  1493.                 Menu;
  1494.               End;
  1495.         '2' : Begin
  1496.                 ShowScreen;
  1497.                 OpenFiles;
  1498.                 BrowseEdit;
  1499.                 CloseFiles;
  1500.                 Menu;
  1501.               End;
  1502.         '3' : Begin
  1503.                 ReportMenu;
  1504.                 Menu;
  1505.               End;
  1506.       End; { case }
  1507.     Until MenuChoice='0';
  1508.   End; { procedure Menu }
  1509.  
  1510. Begin  { main }
  1511.   If MonitorType=7 then TextMode(2) else TextMode(3);
  1512.   TDate:=DOSDate;
  1513.   GetDir(0,EDrive);
  1514.   SetAt;
  1515.   InitIndex;
  1516.   Assign(CFile,ClassFileName);
  1517.   InitializeFiles;
  1518.   RunCount:=5;
  1519.   ParamRead:=False;
  1520.   If ParamCount>0 then begin
  1521.     ShowScreen;
  1522.     OpenFiles;
  1523.     BrowseEdit;
  1524.     CloseFiles;
  1525.     ParamRead:=True;
  1526.     Menu;
  1527.   End Else Menu;
  1528.   ClrScr;
  1529.   RestoreCursor;
  1530. End.